home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / prog / pcl4p40.arj / XYPACKET.PAS < prev   
Pascal/Delphi Source File  |  1993-03-09  |  12KB  |  422 lines
  1. (*********************************************)
  2. (*                                           *)
  3. (*  This program is donated to the Public    *)
  4. (*  Domain by MarshallSoft Computing, Inc.   *)
  5. (*  It is provided as an example of the use  *)
  6. (*  of the Personal Communications Library.  *)
  7. (*                                           *)
  8. (*********************************************)
  9.  
  10.  
  11. { $DEFINE DEBUG}
  12. {$I DEFINES.PAS}
  13.  
  14. unit xypacket;
  15.  
  16. interface
  17.  
  18. type BufferType = array[0..1023] of Byte;
  19.  
  20. Function TxPacket(Port:Integer;
  21.                   PacketNbr:Word;
  22.                   PacketSize:Word;
  23.               Var Buffer:BufferType;
  24.                   NCGbyte:Byte):Boolean;
  25. Function RxPacket(Port:Integer;
  26.                   PacketNbr:Word;
  27.               Var PacketSize:Word;
  28.               Var Buffer:BufferType;
  29.                   NCGbyte:Byte;
  30.               Var EOTflag:Boolean):Boolean;
  31. Function RxStartup(Port:Integer;
  32.               Var NCGbyte:Byte):Boolean;
  33. Function TxStartup(Port:Integer;
  34.               Var NCGbyte:Byte):Boolean;
  35. Function TxEOT(Port:Integer):Boolean;
  36.  
  37.  
  38. implementation
  39.  
  40. uses PCL4P,term_io,crc,hex_io,crt;
  41.  
  42.  
  43. const MAXTRY = 3;
  44.       LIMIT = 20;
  45.  
  46. const SOH = $01;
  47.       STX = $02;
  48.       EOT = $04;
  49.       ACK = $06;
  50.       NAK = $15;
  51.       CAN = $18;
  52.  
  53. Function TxPacket(Port:Integer;         (* Port # [0..3] *)
  54.                   PacketNbr:Word;       (* Packet # [0,1,2,...] *)
  55.                   PacketSize:Word;      (* Packet size [128,1024] *)
  56.               Var Buffer:BufferType;    (* 1K character buffer *)
  57.                   NCGbyte:Byte)         (* NAK, 'C', or 'G' *)
  58.                 : Boolean;              (* successfull *)
  59. Label 999;
  60. Var
  61.   I         : Integer;
  62.   Code      : Integer;
  63.   CheckSum  : Word;
  64.   Attempt   : Word;
  65.   PacketType: Byte;
  66. Begin
  67.   (* better be 128 or 1024 packet length *)
  68.   if PacketSize = 1024
  69.       then PacketType := STX
  70.       else PacketType := SOH;
  71.   PacketNbr := PacketNbr and $00ff;
  72.   (* make up to MAXTRY attempts to send this packet *)
  73.   for Attempt := 1 to MAXTRY do
  74.     begin
  75.       (* send SOH/STX  *)
  76.       PutChar(Port,PacketType);
  77.       (* send packet # *)
  78.       PutChar(Port,PacketNbr);
  79.       (* send 1's complement of packet *)
  80.       PutChar(Port,255-PacketNbr);
  81.       (* send data *)
  82.       CheckSum := 0;
  83.       for i := 0 to PacketSize - 1 do
  84.         begin
  85.           PutChar(Port,Buffer[i]);
  86.           (* update checksum *)
  87.           if NCGbyte<>NAK then CheckSum := UpdateCRC(CheckSum, Buffer[i])
  88.           else CheckSum := CheckSum + Buffer[i];
  89.         end;
  90. {$IFDEF DEBUG}
  91. write('<Checksum=$');
  92. WriteHexWord(CheckSum);
  93. write('>');
  94. {$ENDIF}
  95.       (* send checksum *)
  96.       if NCGbyte<>NAK then
  97.         begin
  98.           (* send 2 byte CRC *)
  99.           PutChar(Port, (CheckSum shr 8) and $00ff );
  100.           PutChar(Port, CheckSum and $00ff );
  101.         end
  102.       else (* NCGbyte = 'C' or 'G' *)
  103.         begin
  104.           (* send one byte checksum *)
  105.           PutChar(Port,CheckSum );
  106.         end;
  107.       (* don't wait for ACK if 'G' *)
  108.       if NCGbyte = Ord('G') then
  109.         begin
  110.            if PacketNbr = 0 then delay(SHORT_WAIT*ONE_SECOND div 2);
  111.            TxPacket := TRUE;
  112.            Goto 999
  113.         end;
  114.       (* wait for receivers ACK *)
  115.       Code := GetChar(Port,LONG_WAIT*ONE_SECOND);
  116.       if Code = CAN then
  117.          begin
  118.             WriteLn('Canceled by remote');
  119.             TxPacket := FALSE;
  120.             Goto 999;
  121.           end;
  122.       if Code = ACK then
  123.           begin
  124.             TxPacket := TRUE;
  125.             Goto 999
  126.           end;
  127.       if Code <> NAK then
  128.           begin
  129.             WriteLn('Out of sync');
  130.             TxPacket := FALSE;
  131.             Goto 999;
  132.           end;
  133.     end; (* end for *)
  134.   (* can't send packet ! *)
  135.   Writeln('Packet timeout for port ',Port);
  136.   TxPacket := FALSE;
  137.  999: end; (* end -- TxPacket *)
  138.  
  139. Function RxPacket(Port:Integer;           (* Port # 0..3 *)
  140.                   PacketNbr:Word;         (* Packet # [0,1,2,...] *)
  141.               Var PacketSize:Word;        (* Packet size (128 or 1024) *)
  142.               Var Buffer:BufferType;      (* 1K buffer *)
  143.                   NCGbyte:Byte;           (* NAK, 'C', or 'G' *)
  144.               Var EOTflag:Boolean)        (* EOT was received *)
  145.                   :Boolean;               (* success / failure *)
  146. Label 999;
  147. Var
  148.   I            : Integer;
  149.   Code         : Integer;
  150.   Attempt      : Word;
  151.   RxPacketNbr  : Word;
  152.   RxPacketNbrC : Word;
  153.   CheckSum     : Word;
  154.   RxCheckSum   : Word;
  155.   RxCheckSum1  : Word;
  156.   RxCheckSum2  : Word;
  157.   PacketType   : Byte;
  158. begin
  159.   PacketNbr := PacketNbr AND $00ff;
  160.   for Attempt := 1 to MAXTRY do
  161.     begin
  162.       (* wait for SOH / STX *)
  163.       Code := GetChar(Port,LONG_WAIT*ONE_SECOND);
  164.       if Code = -1 then
  165.         begin
  166.           WriteLn('Timed out waiting for sender');
  167.           RxPacket := FALSE;
  168.           Goto 999
  169.         end;
  170.       case Code of
  171.         SOH: begin
  172.                (* 128 byte buffer incoming *)
  173.                PacketType := SOH;
  174.                PacketSize := 128
  175.              end;
  176.         STX: begin
  177.                (* 1024 byte buffer incoming *)
  178.                PacketType := STX;
  179.                PacketSize := 1024;
  180.              end;
  181.         EOT: begin
  182.                (* all packets have been sent *)
  183.                PutChar(Port,ACK);
  184.                EOTflag := TRUE;
  185.                RxPacket := TRUE;
  186.                goto 999
  187.              end;
  188.         CAN: begin
  189.                (* sender has canceled ! *)
  190.                SayError(Port,'Canceled by remote');
  191.                RxPacket := FALSE;
  192.              end;
  193.         else
  194.             begin
  195.               (* error ! *)
  196.               Write('Expecting SOH/STX/EOT/CAN not $');
  197.               WriteHexByte(Code);
  198.               Writeln;
  199.               RxPacket := FALSE;
  200.             end;
  201.       end;
  202.       (* receive packet # *)
  203.       Code := GetChar(Port,ONE_SECOND);
  204.       if Code = -1 then
  205.         begin
  206.           WriteLn('timed out waiting for packet #');
  207.           goto 999;
  208.         end;
  209.       RxPacketNbr := $00ff and Code;
  210.       (* receive 1's complement *)
  211.       Code := GetChar(Port,ONE_SECOND);
  212.       if Code =-1 then
  213.         begin
  214.           WriteLn('timed out waiting for complement of packet #');
  215.           RxPacket := FALSE;
  216.           Goto 999
  217.         end;
  218.       RxPacketNbrC := $00ff and Code;
  219.       (* receive data *)
  220.       CheckSum := 0;
  221.       for i := 0 to PacketSize - 1 do
  222.         begin
  223.           Code := GetChar(Port,ONE_SECOND);
  224.           if Code = -1 then
  225.             begin
  226.               WriteLn('timed out waiting for data for packet #');
  227.               RxPacket := FALSE;
  228.               Goto 999
  229.             end;
  230.           Buffer[i] := Code;
  231.           (* compute CRC or checksum *)
  232.           if NCGbyte<>NAK
  233.             then CheckSum := UpdateCRC(CheckSum,Code)
  234.             else CheckSum := (CheckSum + Code) AND $00ff;
  235.         end;
  236.       (* receive CRC/checksum *)
  237.       if NCGbyte<>NAK then
  238.         begin
  239.           (* receive 2 byte CRC *)
  240.           Code := GetChar(Port,ONE_SECOND);
  241.           if Code =-1 then
  242.             begin
  243.               WriteLn('timed out waiting for 1st CRC byte');
  244.               RxPacket := FALSE;
  245.               Goto 999
  246.             end;
  247.           RxCheckSum1 := Code AND $00ff;
  248.           Code := GetChar(Port,ONE_SECOND);
  249.           if Code =-1 then
  250.             begin
  251.               WriteLn('timed out waiting for 2nd CRC byte');
  252.               RxPacket := FALSE;
  253.               Goto 999
  254.             end;
  255.           RxCheckSum2 := Code AND $00ff;
  256.           RxCheckSum := (RxCheckSum1 SHL 8) OR RxCheckSum2;
  257.         end
  258.       else
  259.         begin
  260.           (* receive one byte checksum *)
  261.           Code := GetChar(Port,ONE_SECOND);
  262.           if Code = -1 then
  263.             begin
  264.               WriteLn('timed out waiting for checksum');
  265.               RxPacket := FALSE;
  266.               Goto 999
  267.              end;
  268.           RxCheckSum := Code AND $00ff;
  269.         end;
  270. {$IFDEF DEBUG}
  271. write('<Checksum: Received=$');
  272. WriteHexWord(RxCheckSum);
  273. write(', Computed=$');
  274. WriteHexWord(CheckSum);
  275. write('>');
  276. {$ENDIF}
  277.      (* don't send ACK if 'G' *)
  278.       if NCGbyte = Ord('G') then
  279.         begin
  280.            RxPacket := TRUE;
  281.            Goto 999
  282.         end;
  283.      (* packet # and checksum OK ? *)
  284.      if (RxCheckSum=CheckSum) and (RxPacketNbr=PacketNbr) then
  285.        begin
  286.          (* ACK the packet *)
  287.          PutChar(Port,ACK);
  288.          RxPacket := TRUE;
  289.          Goto 999
  290.        end;
  291.      (* bad packet *)
  292.      WriteMsg('Bad Packet',1);
  293.      PutChar(Port,NAK)
  294.    end;
  295.    (* can't receive packet *)
  296.    SayError(Port,'RX packet timeout');
  297.    RxPacket := FALSE;
  298. 999: end; (* end -- RxPacket *)
  299.  
  300. Function TxStartup(Port:Integer;
  301.                Var NCGbyte:Byte):Boolean;
  302. Label 999;
  303. Var
  304.   Code : Integer;
  305.   I : Integer;
  306.   Result : Boolean;
  307. Begin
  308.   (* clear Rx buffer *)
  309.   Code := SioRxFlush(Port);
  310.   (* wait for receivers start up NAK or 'C' *)
  311.   for i := 1 to LIMIT do
  312.     begin
  313.       if KeyPressed then
  314.         begin
  315.           SayError(Port,'Aborted by user');
  316.           Result := FALSE;
  317.           Goto 999
  318.         end;
  319.       Code := GetChar(Port,SHORT_WAIT*ONE_SECOND);
  320.       if Code <> -1  then
  321.         begin
  322.          (* received a byte *)
  323.          if Code = NAK then
  324.            begin
  325.              NCGbyte := NAK;
  326.              Result := TRUE;
  327.              Goto 999
  328.           end;
  329.         if Code = Ord('C') then
  330.           begin
  331.             NCGbyte := Ord('C');
  332.             Result := TRUE;
  333.             Goto 999
  334.           end;
  335.         if Code = Ord('G') then
  336.           begin
  337.             NCGbyte := Ord('G');
  338.             Result := TRUE;
  339.             Goto 999
  340.           end
  341.         end
  342.       end;
  343.   (* no response *)
  344.   SayError(Port,'No response from receiver');
  345.   TxStartup := FALSE;
  346. 999:
  347.   TxStartup := Result;
  348. {$IFDEF DEBUG}
  349.   write('<TxStartup ');
  350.   if Result then writeln('successfull>')
  351.   else writeln('fails>');
  352. {$ENDIF}
  353. end; (* end -- TxStartup *)
  354.  
  355.  
  356. Function RxStartup(Port:Integer;
  357.                Var NCGbyte:Byte)
  358.                  : Boolean;
  359. Label 999;
  360. Var
  361.   I : Integer;
  362.   Code : Integer;
  363.   Result : Boolean;
  364. Begin
  365.   (* clear Rx buffer *)
  366.   Code := SioRxFlush(Port);
  367.   (* Send NAKs or 'C's *)
  368.   for I := 1 to LIMIT do
  369.     begin
  370.       if KeyPressed then
  371.         begin
  372.           SayError(Port,'Canceled by user');
  373.           Result := FALSE;
  374.           Goto 999
  375.         end;
  376.       (* stop attempting CRC after 1st 4 tries *)
  377.       if (NCGbyte<>NAK) and (i=5) then  NCGbyte := NAK;
  378.       (* tell sender that I am ready to receive *)
  379.       PutChar(Port,NCGbyte);
  380.       Code := GetChar(Port,SHORT_WAIT*ONE_SECOND);
  381.       if Code <> -1 then
  382.         begin
  383.           (* no error -- must be incoming byte -- push byte back onto queue ! *)
  384.           Code := SioUnGetc(Port,Code);
  385.           Result := TRUE;
  386.           Goto 999
  387.         end;
  388.     end; (* for i *)
  389.   (* no response *)
  390.   SayError(Port,'No response from sender');
  391.   Result := FALSE;
  392. 999:
  393.   RxStartup := Result;
  394. {$IFDEF DEBUG}
  395.   write('<RxStartup ');
  396.   if Result then writeln('successfull>')
  397.   else writeln('fails>');
  398. {$ENDIF}
  399. end; (* end -- RxStartup *)
  400.  
  401. Function TxEOT(Port:Integer):Boolean;
  402. Label 999;
  403. Var
  404.   I    : Integer;
  405.   Code : Integer;
  406. Begin
  407.   for I := 0 to 10 do
  408.     begin
  409.       PutChar(Port,EOT);
  410.       (* await response *)
  411.       Code := GetChar(Port,SHORT_WAIT*ONE_SECOND);
  412.       if Code = ACK then
  413.         begin
  414.           TxEOT := TRUE;
  415.           Goto 999
  416.         end
  417.     end; (* end -- for I) *)
  418.   TxEOT := FALSE;
  419. 999: end; (* end -- TxEOT *)
  420.  
  421. end.
  422.